/* fafamti.p - FIXED ASSETS MAINTENANCE - Retire Asset                      */
/* Copyright 1986 QAD Inc. All rights reserved.                               */
/* $Id:: fafamti.p 38391 2014-01-09 03:28:38Z c5l                          $: */
/* REVISION: 9.1      LAST MODIFIED: 10/26/99   BY: *N021* Pat Pigatti      */
/* REVISION: 9.1      LAST MODIFIED: 03/24/00   BY: *N08T* Annasaheb Rahane */
/* REVISION: 9.1      LAST MODIFIED: 05/17/00   BY: *M0LJ* Vihang Talwalkar */
/* REVISION: 9.1      LAST MODIFIED: 07/28/00   BY: *N0BX* Arul Victoria    */
/* REVISION: 9.1      LAST MODIFIED: 08/14/00   BY: *N0L0* Jacolyn Neder    */
/* REVISION: 9.1      LAST MODIFIED: 09/28/00   BY: *M0T5* Rajesh Lokre     */
/* Revision: 1.16.1.11      BY: Ashish M           DATE: 10/11/01 ECO: *M1M1* */
/* Revision: 1.16.1.13      BY: Paul Donnelly (SB) DATE: 06/26/03 ECO: *Q00C* */
/* Revision: 1.16.1.15      BY: Dorota Hohol       DATE: 10/20/03 ECO: *P138* */
/* Revision: 1.16.1.16      BY: Ajay Nair          DATE: 08/01/06 ECO: *P4YV* */
/* Revision: 1.16.1.17      BY: Katie Hilbert      DATE: 03/06/07 ECO: *R0C6* */
/* Revision: 1.16.1.18      BY: Jean Miller        DATE: 03/04/09 ECO: *R1DF* */
/* Revision: 1.16.1.19      BY: Mallika S. Poojary DATE: 03/04/09 ECO: *R1DC* */
/* Revision: 1.16.1.20      BY: Mukesh Singh       DATE: 03/23/09 ECO: *Q2LB* */
/* Revision: 1.16.1.22      BY: Mukesh Singh       DATE: 01/07/10 ECO: *R1W8* */
/* REVISION: 17360     LAST MODIFIED: 05/04/12    BY: ddo                     */
/* $Revision: 1.16.1.23 $      BY: Ashim Mishra       DATE: 06/21/10 ECO: *Q3TF* */
/*-Revision end---------------------------------------------------------------*/
/******************************************************************************/
/* All patch markers and commented out code have been removed from the source */
/* code below. For all future modifications to this file, any code which is   */
/* no longer required should be deleted and no in-line patch markers should   */
/* be added.  The ECO marker should only be included in the Revision History. */
/******************************************************************************/

{us/bbi/mfdeclre.i}
{us/bbi/gplabel.i} /* EXTERNAL LABEL INCLUDE */
{us/gp/gprunpdf.i "mcpl" "p"} 
{us/px/pxmaint.i}
{us/px/pxphdef.i gpcodxr}

define query q_fa_mstr
   for fa_mstr
   scrolling.

/* -----------------  STANDARD VARIABLES  ---------------- */
define variable p-status       as character no-undo.
define variable perform-status as character format "x(25)"
   initial "first" no-undo.
define variable p-skip-update  like mfc_logical no-undo.
define variable l-rowid        as rowid     no-undo.
define variable l-delete-it    like mfc_logical no-undo.
define variable l-del-rowid    as rowid     no-undo.
define variable l-top-rowid    as rowid     no-undo.
define variable lines          as integer   initial 10 no-undo.
define variable l-found        like mfc_logical no-undo.
define variable pos            as integer   no-undo.
define variable l-first        like mfc_logical no-undo.
define variable l-error        like mfc_logical no-undo.
define variable l-title        as character no-undo.
define variable l_full_retire  like mfc_logical no-undo.

/* ------------------  BUTTON VARIABLES  ----------------- */
define button b-update label "Update".
define button b-undo   label "Undo".
define button b-books  label "Books".
define button b-end    label "End".

/* -------------  STANDARD WIDGET VARIABLES  ------------- */
define variable l-focus           as widget-handle no-undo.
define variable w-frame           as widget-handle no-undo.

/* ------------------  SCREEN VARIABLES  ----------------- */
define shared variable l-key             as character     format "x(12)"
   initial """" no-undo.
define variable l-new-rt          like mfc_logical no-undo.
define variable l-ret-yrper       as character     format "x(6)" no-undo.
define variable l-cal             as character     format "x(8)"
   initial """" no-undo.
define variable l-err-nbr         as integer       format ">>>9"
   initial 0 no-undo.
define variable correct-yn        like mfc_logical
   initial yes no-undo.
define variable fa_dispamt_fmt    as character     format "x(30)" no-undo.
define variable l-post-cal        as character     format "x(8)" no-undo.
define variable l-post-fabk-id    as character     format "x(4)" no-undo.
define variable l-partial         like mfc_logical
   initial no no-undo.
define variable l-disp-desc       as character     format "x(45)" no-undo.
define variable l-amt             as decimal       format "->>>,>>>,>>9.99<"
   no-undo.
define variable l-new             as character     format "x(12)" no-undo.
define variable l-pct             as decimal       format ">>9.99<"
   initial 0 no-undo.
define variable l-nrm-err         like mfc_logical
   initial no no-undo.
define variable l-total           as decimal       format "->>>,>>>,>>9.99<"
   no-undo.
define shared variable l-reopen-fa-query like mfc_logical no-undo.
define variable l-suspend         like mfc_logical no-undo.
define variable l-post            like mfc_logical no-undo.

define variable l_amt_fmt         as character     no-undo.
define variable mc-error-number   like msg_nbr no-undo.
define variable rndmthd           like rnd_rnd_mthd no-undo.
define variable l_cu_mstr         as character     no-undo.
/* ------------------  FRAME DEFINITION  ----------------- */
/* Added side-labels phrase to frame statement              */

define frame f-button
   b-update at 1
   b-undo   at 10
   b-books  at 19
   b-end    at 28
   with no-box overlay three-d side-labels width 37.

/* CLEAR FRAME REGISTRATION TO TRANSLATE THE FRAME EVERYTIME*/
clearFrameRegistration(frame f-button:handle).

/* SET EXTERNAL LABELS */
setFrameLabels(frame f-button:handle).

assign
   l-focus               = b-update:handle in frame f-button
   b-update:width        = 8
   b-update:private-data = "update"
   b-undo:width          = 8
   b-undo:private-data   = "undo"
   b-books:width         = 8
   b-books:private-data  = "books"
   b-end:width           = 8
   b-end:private-data    = "end".

/* Changing the frame names from f-1 to f_1 as the underlying frame name is
   also f-1 which is causing problems in .NetUI. */
define frame f_1
   skip(.4)
   fa_id colon 19
   fa_desc1 no-labels at 34
   format "x(45)"
   skip
   fa_disp_dt colon 19
   skip
   fa_disp_rsn colon 19
   l-disp-desc no-labels at 34
   skip
   fa_dispamt colon 19
   l_cu_mstr  at 45
   skip
   l-partial label "Partial" colon 19
   with three-d overlay side-labels width 80.

/* CLEAR FRAME REGISTRATION TO TRANSLATE THE FRAME EVERYTIME*/
clearFrameRegistration(frame f_1:handle).

/* SET EXTERNAL LABELS */
setFrameLabels(frame f_1:handle).

run ip-framesetup.

w-frame = frame f_1:handle.
{us/bbi/gprun.i ""fafmtut.p""
   "(w-frame)"}

/* ---------------  PRE PROCESSING INCLUDE  -------------- */
/* VARIABLES FOR GPGLEF1.P */
{us/gp/gpglefv.i}

define new shared workfile temp-select
   field sel_idr    as character format "x(1)"
   field sel_tag    as character format "x(17)"
   field sel_desc   as character format "x(20)"
   field sel_amt    as decimal   format ">>>,>>>,>>9.99<"
   field sel_serial as character format "x(20)".

define new shared temp-table tt_fa_accts no-undo
   fields tt_fa_id     like faba_fa_id
   fields tt_fabk_id   like faba_fabk_id
   fields tt_acct_type like faba_acctype
   fields tt_fa_acct   like faba_acct
   fields tt_fa_sub    like faba_sub
   fields tt_fa_cc     like faba_cc
   index tt_fa_accts is primary tt_fa_id tt_fabk_id tt_acct_type tt_fa_acct.


for first fa_mstr where fa_mstr.fa_domain = global_domain
   and fa_id = l-key
   no-lock: 
end. /* FOR FIRST fa_mstr */

/* RETRIEVE THE POSTING BOOK */
for first fabk_mstr where fabk_mstr.fabk_domain = global_domain
   and fabk_post    = yes
   and fabk_primary = yes
   no-lock:
   assign
      l-post-fabk-id = fabk_id
      l-post-cal     = fabk_calendar.
end. /* FOR FIRST fabk_mstr */

/* get the primary book currency */
for first fabk_mstr no-lock
   where fabk_domain= global_domain and fabk_primary = yes,
   cu_mstr of fabk_mstr:
   assign 
      l_cu_mstr = cu_mstr.cu_curr.
   
	{us/gp/gprunp.i "mcpl" "p" "mc-get-rnd-mthd"
				 "(input l_cu_mstr,
					output rndmthd,
					output mc-error-number)"}
	if mc-error-number <> 0 then 
	do:
		{us/bbi/pxmsg.i &MSGNUM=mc-error-number &ERRORLEVEL=3}
	end.
end.

/* SET CURRENCY DEPENDENT ROUNDING FORMATS */
for first gl_ctrl where gl_ctrl.gl_domain = global_domain
   no-lock: 
end. /* FOR FIRST gl_ctrl */
if rndmthd = ? or rndmthd = ''
then do:
	assign rndmthd = gl_rnd_mthd.
end.
assign fa_dispamt_fmt = "->>>,>>>,>>9.99<"
			l_amt_fmt = "->>>,>>>,>>9.99<".

{us/bbi/gprun.i ""gpcurfmt.p""
   "(input-output fa_dispamt_fmt,
     input rndmthd)"}
fa_mstr.fa_dispamt:format = fa_dispamt_fmt.
/* -------------  END PRE PROCESSING INCLUDE  ------------ */

open query q_fa_mstr
   for each fa_mstr where fa_mstr.fa_domain = global_domain
   and fa_id = l-key
   no-lock.

get first q_fa_mstr
   no-lock.

main-loop:
do while perform-status <> "end" on error undo:
   /* -------------  TOP OF MAIN-LOOP INCLUDE  ------------ */
   if perform-status = "first" or
      perform-status = "end"
   then do:
      assign
         p-status = (if perform-status = "first"
                        then "first-one"
                        else "end").

      if available fa_mstr
      then
         {us/bbi/gprun.i ""fafamtm.p""
            "(input p-status,
              buffer fa_mstr)"}
      pause 0. /* KEEP PAUSE 0 TO AVOID PRESS SPACEBAR MSG */
      p-status = "".
   end. /* IF perform-status */
   /* -----------  END TOP OF MAIN-LOOP INCLUDE  ---------- */

   if perform-status = "first"
   then do:
      assign 
         p-status = "first-one".
      if available fa_mstr then
         {us/bbi/gprun.i ""fafamtm.p""
         "(input p-status,
           buffer fa_mstr)"}
      p-status = "".
   end. /* IF perform-status = "first" */
   if perform-status = "end" or
      perform-status = "add"
   then do:
      p-status = perform-status.
      if available fa_mstr
      then
         {us/bbi/gprun.i ""fafamtm.p""
         "(input p-status,
           buffer fa_mstr)"}
      p-status = "".
   end. /* IF perform-status = "end" ... */

   run ip-query
      (input-output perform-status,
      input-output l-rowid).

   /* -----------------------  UNDO  ---------------------- */
   if perform-status = "undo"
   then do:
      assign
         l-new-rt       = yes
         perform-status = "update"
         p-status       = "undo".

      run ip-lock(input-output perform-status).
      assign
         perform-status = ""
         p-status       = "".
   end. /* IF perform-status = "undo" */
   /* ---------------------  END UNDO  -------------------- */

   /* ----------------------  BOOKS  ---------------------- */
   if perform-status = "books"
   then do:
      p-status = "display".
      if session:display-type = "gui"
      then
         assign
            fa_id:bgcolor = 8
            fa_id:fgcolor = 0.
      else
         color display normal fa_id
            with frame f_1.
      if available fa_mstr
      then
         {us/bbi/gprun.i ""fafamtm.p""
            "(input p-status,
              buffer fa_mstr)"}
      assign
         p-status       = ""
         perform-status = "first".
      run ip-displayedits.
   end. /* IF perform-status = "books" */
   /* --------------------  END BOOKS  -------------------- */

   /* ----------------------  DISPLAY  ---------------------- */
   run ip-predisplay.

   if (perform-status = "update" or
      perform-status = "add")
   then do:
      run ip-prompt.
      if perform-status = "undo"
      then do:
         perform-status = "first".
         next main-loop.
      end. /* IF perform-status = "undo" */
      run ip-displayedits.
   end. /* IF (perform-status = "update" ... */

   /* ----------------  SELECTION BUTTONS  ---------------- */
   if perform-status <> "first"
   then
      run ip-button
         (input-output perform-status).

   /* -------------  AFTER STRIP MENU INCLUDE  ------------ */
   if perform-status = "undo" and
      fa_disp_dt     = ?
   then do:
      /* CANNOT UNDO - ASSET HAS NOT YET BEEN RETIRED */
      {us/bbi/pxmsg.i &MSGNUM=3270 &ERRORLEVEL=3}
      perform-status = "".
   end. /* IF perform-status = "undo" ... */

   if perform-status = "update" or
      perform-status = "undo"
   then do:
      /* MAKE SURE PREVIOUS ENTERED RETIREMENT IS NOT POSTED */
      if fa_disp_dt <> ?
      then do:
         {us/gp/gprunp.i "fapl" "p" "fa-get-per"
            "(input  fa_disp_dt,
              input  l-post-cal,
              output l-ret-yrper,
              output l-err-nbr)"}

         {us/gp/gprunp.i "fapl" "p" "fa-get-post"
            "(input  fa_id,
              input  l-post-fabk-id,
              input  l-ret-yrper,
              output l-post)"}

         if l-post
         then do:
            if perform-status = "update"
            then do:
               /* CANNOT UPDATE - RETIREMENT ALREADY POSTED */
               {us/bbi/pxmsg.i &MSGNUM=3233 &ERRORLEVEL=3}
            end. /* IF perform-status = "update" */
            else 
            do:
               /* CANNOT UNDO - RETIREMENT ALREADY POSTED */
               {us/bbi/pxmsg.i &MSGNUM=3213 &ERRORLEVEL=3}
            end. /* ELSE DO */
            perform-status = "".
         end.  /* IF l-post */
         else do:
            if perform-status = "update"
            then do:
               /*ASSET ALREADY RETIRED, PLEASE UNDO PREVIOUS RETIREMENT*/
               {us/bbi/pxmsg.i &MSGNUM=25325 &ERRORLEVEL=3}
               perform-status = "".
            end.
         end.
      end.  /* IF fa_disp_dt <> ? */
   end.  /* IF perform-status = "update" ... */
   if perform-status = "undo"
   then do:
      correct-yn = yes.
      /* IS ALL INFORMATION CORRECT */
      {us/bbi/pxmsg.i &MSGNUM=12 &ERRORLEVEL=1 &CONFIRM=correct-yn}
      if correct-yn = no
      then
         perform-status = "first".
   end. /* IF perform-status = "undo" */
   /* -----------  END AFTER STRIP MENU INCLUDE  ---------- */

   /* -----------------------  END  ----------------------- */
   if perform-status = "end"
   then do:
      hide frame f_1 no-pause.
      delete PROCEDURE this-procedure no-error.
      leave.
   end. /* IF perform-status = "end" */
end. /* DO WHILE */

/* -------------  ADD / UPDATE / FIELD EDITS  ------------ */
PROCEDURE ip-prompt:
   if perform-status = "add"
   then
      clear frame f_1 all no-pause.
   l-first = yes.
   CASE perform-status:
      when ("add")
      then
         /* ADDING NEW RECORD */
         {us/bbi/pxmsg.i &MSGNUM=1 &ERRORLEVEL=1}
      when ("update")
      then
         /* MODIFYING EXISTING RECORD */
         {us/bbi/pxmsg.i &MSGNUM=10 &ERRORLEVEL=1}
      otherwise
      hide message no-pause.
   END CASE. /* perform-status */

   ststatus = stline[3].
   status input ststatus.
   prompt-for-it:
   repeat:
      l-first = no.
      repeat:
         prompt-for
            fa_mstr.fa_disp_dt
            fa_mstr.fa_disp_rsn
            with frame f_1.

         if input frame f_1 fa_disp_dt = ?
         then do:
            /* DATE REQUIRED */
            {us/bbi/pxmsg.i &MSGNUM=711 &ERRORLEVEL=3}
            next-prompt fa_disp_dt with frame f_1.
            next.
         end. /* IF INPUT FRAME f_1 fa_disp_dt = ? */
         /* FIELD EDIT FOR fa_disp_dt */
         l-error = no.
         /* VALIDATE RETIREMENT DATE AGAINST GL CALENDAR */
         {us/bbi/gprun.i ""gpglef1.p""
            "(input ""FA"",
              input fa_mstr.fa_entity,
              input input frame f_1 fa_disp_dt,
              output gpglef_result,
              output gpglef_msg_nbr)"}
         /* ONLY DISPLAY A WARNING IF CLOSED PERIOD */
         if gpglef_result = 2
         then do:
            /* CLOSED PERIOD */
            {us/bbi/pxmsg.i &MSGNUM=gpglef_msg_nbr &ERRORLEVEL=2}
         end.
         else if gpglef_result <> 0
               then 
            do:
               /* INVALID PERIOD OR INACTIVE ENTITY */
               {us/bbi/pxmsg.i &MSGNUM=gpglef_msg_nbr &ERRORLEVEL=3 &MSGAR1=fa_mstr.fa_entity}
               l-error = yes.
            end.  /* IF gpglef_result = 2 */

         if l-error = no
         then
            /* CHECK AGAINST STARTING DATE */
            if input frame f_1 fa_disp_dt <= fa_startdt
            then do:
               /* RETIREMENT DATE MUST BE LATER THAN START DATE */
               {us/bbi/pxmsg.i &MSGNUM=3231 &ERRORLEVEL=3}
               l-error = yes.
            end. /* IF l-error = no */

         if l-error = no then
            BOOK-CYCLE:
            for each fab_det where fab_det.fab_domain = global_domain
               and fab_fa_id = l-key
               no-lock
               break by fab_fabk_id:
               if first-of(fab_fabk_id)
               then do:
                  for first fabk_mstr where fabk_mstr.fabk_domain = global_domain
                     and fabk_id = fab_fabk_id
                     no-lock: 
                  end. /* FOR FIRST fabk_mstr */
                  if available fabk_mstr
                  then do:
                     l-cal = (if fabk_post
                        then ""
                        else fabk_calendar).

                     {us/gp/gprunp.i "fapl" "p" "fa-get-per"
                     "(input  input frame f_1 fa_disp_dt,
                       input  l-cal,
                       output l-ret-yrper,
                       output l-err-nbr)"}
                     if l-err-nbr <> 0
                     then do:
                        {us/bbi/pxmsg.i &MSGNUM=l-err-nbr &ERRORLEVEL=3}
                        l-error = yes.
                        Leave BOOK-CYCLE.
                     end. /* IF l-err-nbr <> 0 */

                     if fabk_id = l-post-fabk-id
                     then do:
                        {us/gp/gprunp.i "fapl" "p" "fa-get-post"
                        "(input  fab_fa_id,
                          input  fab_fabk_id,
                          input  l-ret-yrper,
                          output l-post)"}

                        if l-post
                        then do:
                           /* CANNOT RETIRE - DEPRECIATION POSTED */
                           {us/bbi/pxmsg.i &MSGNUM=3268 &ERRORLEVEL=3}
                           l-error = yes.
                           leave BOOK-CYCLE.
                        end. /* IF l-post */
                     end. /* IF fabk_id = l-post-fabk-id */

                     for first fabd_det no-lock
                        where fabd_det.fabd_domain = global_domain
                        and fabd_fa_id = fab_fa_id
                        and fabd_fabk_id = fab_fabk_id
                        and fabd_yrper  >= l-ret-yrper
                        break by fabd_yrper:
                     end.

                     if available fabd_det
                        and fabd_suspend  = yes
                     then do:
                        /* CANNOT RETIRE - DEPRECIATION SUSPENDED */
                        {us/bbi/pxmsg.i &MSGNUM=3230 &ERRORLEVEL=3}
                        l-error = yes.
                        leave BOOK-CYCLE.
                     end. /* IF CAN-FIND fabd_det ... */
                     else 
                     do:
                        for last fabd_det no-lock
                           where fabd_det.fabd_domain = global_domain
                           and   fabd_fa_id           = fab_fa_id
                           and   fabd_fabk_id         = fab_fabk_id:
                        end.
                        if available fabd_det
                           and   fabd_suspend         = yes
                           and   l-ret-yrper          > fabd_yrper
                        then do:
                           /* CANNOT RETIRE - DEPRECIATION SUSPENDED */
                           {us/bbi/pxmsg.i &MSGNUM=3230 &ERRORLEVEL=3}
                           l-error = yes.
                           leave BOOK-CYCLE.
                        end.
                     end. /* else*/
                  end.  /* IF AVAILABLE fabk_mstr */
               end.  /* IF FIRST-OF(fab_fabk_id) */
            end.  /* FOR EACH fab_det */
         if l-error
         then do:
            next-prompt fa_disp_dt with frame f_1.
            next.
         end. /* IF l-error */
         /* END FIELD EDIT FOR fa_disp_dt */

         /* FIELD EDIT FOR fa_disp_rsn */
         l-error = no.
         {us/px/pxrun.i &PROC='getGeneralizedCodeDescription' &PROGRAM='gpcodxr.p'
            &HANDLE=ph_gpcodxr
            &PARAM="(input 'fa_disp_rsn',
                     input input frame f_1 fa_disp_rsn,
                     output l-disp-desc)"
            &NOAPPERROR=true
            &CATCHERROR=true}
         l-disp-desc:screen-value = l-disp-desc.

         if l-error
         then do:
            next-prompt fa_disp_rsn with frame f_1.
            next.
         end. /* IF l-error */
         /* END FIELD EDIT FOR fa_disp_rsn */

         leave.
      end. /*  REPEAT */

      if keyfunction(lastkey) = "end-error"
      then do:
         perform-status = "undo".
         return no-apply.
      end. /* IF keyfunction(lastkey) = "end-error" */

      repeat:
         assign
            fa_mstr.fa_dispamt:format in frame f_1 = l_amt_fmt.

         prompt-for
            fa_mstr.fa_dispamt
            l-partial
            with frame f_1.

         assign
            l-partial.
         /* FIELD EDIT FOR fa_dispamt */
         l-error = no.
         /* CHECK CURRENCY DEPENDENT ROUNDING FORMAT */
         {us/bbi/gprun.i ""gpcurval.p""
            "(input input frame f_1 fa_mstr.fa_dispamt,
              input rndmthd,
              output l-err-nbr)"}
         if l-err-nbr <> 0
         then
            assign
               l-error   = yes
               l-err-nbr = 0.
         if l-error
         then do:
            next-prompt fa_dispamt with frame f_1.
            next.
         end. /* IF l-error */
         /* END FIELD EDIT FOR fa_dispamt */

         /* FIELD EDIT FOR l-partial */
         l-error = no.
         /* IS ALL INFORMATION CORRECT */
         {us/bbi/pxmsg.i &MSGNUM=12 &ERRORLEVEL=1 &CONFIRM=correct-yn}

         if not correct-yn
         then do:
            l-error = yes.
            next-prompt fa_disp_dt with frame f_1.
            next.
         end. /* IF not correct-yn */
         if l-error
         then do:
            next-prompt l-partial with frame f_1.
            next.
         end. /* IF l-error */
         /* END FIELD EDIT FOR l-partial */

         leave.
      end. /* REPEAT */
      if keyfunction(lastkey) = "end-error"
      then
         next prompt-for-it.

      /* AFTER-UPDATE-EDITS */
      if perform-status = "update"
      then do:
         /* IF THE RETIREMENT DATE HAS CHANGED, SET L-NEW-RT TO YES SO */
         /* THAT ADJUSTMENT MADE TO THE OLD RETIREMENT CAN BE DELETED  */
         /* AND A NEW ONE CAN BE CREATED IN FARTBL.P                   */
         l-new-rt = input frame f_1 fa_disp_dt <> fa_mstr.fa_disp_dt.
      end. /* IF perform-status = "update" */
      /* AFTER-UPDATE-EDITS */

      leave.
   end. /* prompt-for-it */

   if keyfunction(lastkey) = "end-error"
   then do:
      if perform-status = "add"
      then do:
         /* RECORD NOT ADDED */
         {us/bbi/pxmsg.i &MSGNUM=1304 &ERRORLEVEL=1}
      end. /* IF perform-status = "add" */
      perform-status = "first".
      clear frame f_1.
      get current q_fa_mstr no-lock.
      run ip-displayedits.
      return.
   end. /* IF keyfunction(lastkey) = "end-error" */
   run ip-lock
      (input-output perform-status).
END PROCEDURE. /* ip-promt */

/* -----------------------  LOCKING  ----------------------- */
PROCEDURE ip-lock:
   define input-output parameter perform-status as character no-undo.

   if perform-status = "add" or
      perform-status = "update" or
      perform-status = "delete"
   then
   ip-lock:
   do transaction on error undo:
      assign
         pos         = 0
         l-delete-it = yes.

      if available fa_mstr
      then
         get current q_fa_mstr no-lock.
      if available fa_mstr and
         current-changed fa_mstr
      then do:
         l-delete-it = yes.
         /* RECORD HAS BEEN MODIFIED SINCED YOU EDITED IT SAVE ANYWAY */
         {us/bbi/pxmsg.i &MSGNUM=2042 &ERRORLEVEL=1 &CONFIRM=l-delete-it}
         if l-delete-it = no
         then do:
            hide message no-pause.
            run ip-displayedits.
            return.
         end. /* IF l-delete-it = no */
         hide message no-pause.
      end. /* IF available fa_mstr ... */
      if available fa_mstr
      then
      tran-lock:
      do while perform-status <> "":
         get current q_fa_mstr exclusive-lock no-wait.
         if locked fa_mstr
         then do:
            if pos < 3
            then do:
               pos = pos + 1.
               pause 1 no-message.
               next tran-lock.
            end. /* IF pos < 3 */
            perform-status = "error".
         end. /* IF LOCKED fa_mstr */
         leave.
      end. /* DO WHILE */

      if (perform-status = "update" or
         p-status = "update") and
         l-delete-it = yes
      then
         run ip-update
            (input-output perform-status).

      if perform-status = "delete"
      then
         run ip-delete
            (input-output perform-status).

      if available fa_mstr
      then
         get current q_fa_mstr no-lock.
   end. /* IF perform-status = "add" ... */
   if perform-status = "add"
   then
      run ip-add
         (input-output perform-status).
END PROCEDURE. /* ip-lock */

PROCEDURE ip-update:
   define input-output parameter perform-status as character no-undo.

   if p-status = "update"
   then
      p-status = "".

   /* LOCKED-UPDATE-EDITS */
   /* IF THE RETIREMENT DATE HAS CHANGED THEN DELETE  */
   /* OLD RETIREMENT ADJUSTMENT SO THAT A NEW ONE CAN */
   /* BE CREATED IN FARTBL.P                          */

   if l-new-rt
   then do:
      if fa_mstr.fa_dep = no then
         for each fabd_det where fabd_det.fabd_domain = global_domain
            and fabd_fa_id   = fa_mstr.fa_id
            and fabd_retired = yes
            exclusive-lock:
            delete fabd_det.
         end. /* FOR EACH fabd_det */

      for each fab_det where fab_det.fab_domain = global_domain
         and fab_fa_id = fa_mstr.fa_id
         no-lock
         break by fab_fabk_id:
         if first-of(fab_fabk_id)
         then do:

            /* DELETE ADJUSTMENT MADE TO THE PRIOR RETIREMENT */
            for last faadj_mstr where faadj_mstr.faadj_domain = global_domain
               and faadj_fa_id = fab_fa_id
               and faadj_fabk_id = fab_fabk_id
               exclusive-lock
               use-index faadj_fa_id:

               if faadj_type = "90"
               then do:
                  for each fabd_det where fabd_det.fabd_domain = global_domain
                     and fabd_fa_id = faadj_fa_id
                     and fabd_fabk_id = faadj_fabk_id
                     and fabd_resrv = faadj_resrv
                     exclusive-lock:
                     delete fabd_det.
                  end. /* FOR EACH fabd_det */

                  /* RESET FABD_RETIRED */
                  for each fabd_det where fabd_det.fabd_domain = global_domain
                     and fabd_fa_id = faadj_fa_id
                     and fabd_fabk_id = faadj_fabk_id
                     and fabd_yrper >= faadj_yrper
                     exclusive-lock:
                     fabd_retired = no.
                  end. /* FOR EACH fabd_det */

                  delete faadj_mstr.

               end.  /* IF faadj_type = "90" */

            end. /* FOR LAST faadj_mstr */

         end.  /* IF FIRST-OF(fab_fabk_id) */
      end.  /* FOR EACH fab_det */

      /* IF UNDO RETIREMENT THEN RETURN */
      if p-status = "undo"
      then do:
         assign
            fa_disp_dt  = ?
            fa_dispamt  = 0
            fa_disp_rsn = ""
            l-disp-desc = ""
            p-status    = "first-one".
         {us/bbi/gprun.i ""fafamtm.p""
            "(input p-status,
              buffer fa_mstr)"}
         return.
      end.  /* IF p-status = "undo" */
   end.  /* IF l-new-rt */

   /* IF PARTIAL RETIREMENT THEN PROMPT USER TO ENTER    */
   /* NEW ASSET ID THAT WILL CONTAIN THE RETIRED PORTION */
   /* OF THIS ASSET.  ALSO PROMPT FOR EITHER THE AMOUNT  */
   /* OR PERCENT OF A SINGLE COMPONENT ASSET TO RETIRE   */
   /* OR WHICH COMPONENTS TO RETIRE.                     */
   if input frame f_1 l-partial = yes
   then do:

      /* PROMPT FOR NEW ASSET, PERCENT, AMOUNT AND COMPONENTS */
      {us/bbi/gprun.i ""fafablc.p""
         "(input fa_mstr.fa_id,
           output l-new,
           output l-pct,
           output l-amt,
           output l-err-nbr)"}

      /* CREATE NEW ASSET */
      if l-err-nbr = 0
      then do:
         /* CREATING NEW ASSET.  PLEASE WAIT */
         {us/bbi/pxmsg.i &MSGNUM=832 &ERRORLEVEL=1}
         /* ADDED SIXTH, SEVENTH, EIGHTH, NINTH, TENTH, ELEVENTH PARAMETER */
         {us/bbi/gprun.i ""fafabla.p""
            "(input l-key,
              input-output l-new,
              input l-pct,
              input l-amt,
              input fa_mstr.fa_qty,
              input """",
              input """",
              input """",
              input """",
              input no,
              output l-err-nbr)"}

         hide message no-pause.

         /* NEW ASSET CREATED:  L-NEW */
         {us/bbi/pxmsg.i &MSGNUM=3234 &ERRORLEVEL=1 &MSGARG1=l-new}
         l-reopen-fa-query = yes.

         /* FIND NEW ASSET EXCLUSIVE-LOCK TO RETIRE IT */
         for first fa_mstr where fa_mstr.fa_domain = global_domain
            and fa_id = l-new
            exclusive-lock: 
         end. /* FOR FIRST fa_mstr */

      end.  /* IF l-err-nbr = 0 */
      else if l-err-nbr <> 1
            then 
         do:
            /* 1 = "end-err" or "F4" or "CTRL-E" */
            {us/bbi/pxmsg.i &MSGNUM=l-err-nbr &ERRORLEVEL=4}
            perform-status = "".
            return.
         end. /* ELSE IF l-err-nbr <> 1 */
   end.  /* IF l-partial */
   /* LOCKED-UPDATE-EDITS */

   run ip-assign
      (input-output perform-status).
   perform-status = "open".
   run ip-query
      (input-output perform-status,
      input-output l-rowid).
END PROCEDURE. /* ip-update */

PROCEDURE ip-add:
   define input-output parameter perform-status as character no-undo.

   create fa_mstr.
   fa_mstr.fa_domain = global_domain.
   run ip-assign
      (input-output perform-status).
   perform-status = "open".
   run ip-query
      (input-output perform-status,
      input-output l-rowid).
   perform-status = "first".
   return.
END PROCEDURE. /* ip-add */

PROCEDURE ip-delete:
   define input-output parameter perform-status as character no-undo.
   assign
      l-delete-it = no.
   /* PLEASE CONFIRM DELETE */
   {us/bbi/pxmsg.i &MSGNUM=11 &ERRORLEVEL=1 &CONFIRM=l-delete-it}

   CASE l-delete-it:
      when yes
      then 
         do:
            hide message no-pause.
            delete fa_mstr.
            clear frame f_1 no-pause.
            get next q_fa_mstr no-lock.
            if available fa_mstr
            then do:
               assign
                  perform-status = "first"
                  l-rowid        = rowid(fa_mstr).
            end. /* IF AVAILABLE fa_mstr */
            else 
            do:
               get prev q_fa_mstr no-lock.
               if available fa_mstr
               then do:
                  assign
                     perform-status = "first"
                     l-rowid        = rowid(fa_mstr).
               end. /* IF AVAILABLE fa_mstr */
               else
                  assign
                     perform-status = "first"
                     l-rowid        = rowid(fa_mstr).
            end. /* ELSE DO */

            /* RECORD DELETED */
            {us/bbi/pxmsg.i &MSGNUM=22 &ERRORLEVEL=1}
            return.
         end. /* l-delete-it */
      otherwise
      run ip-displayedits.
   END CASE.
END PROCEDURE. /* ip-delete */

PROCEDURE ip-assign:
   define input-output parameter perform-status as character no-undo.
   do with frame f_1:
      assign
         fa_mstr.fa_disp_dt
         fa_mstr.fa_disp_rsn
         fa_mstr.fa_dispamt
         l-rowid = rowid(fa_mstr).

      if l-err-nbr = 1
      then do:
         {us/bbi/pxmsg.i
            &MSGNUM     = 7453
            &ERRORLEVEL = 2
            &CONFIRM    = l_full_retire}

         if not l_full_retire
         then
            assign
               fa_disp_dt = ?
               fa_dispamt = 0.
      end. /* IF l-err-nbr = 1 */

      /* --------  /* AFTER-ASSIGN-AUDIT-INCLUDE */  ----------- */
      if l-new-rt   = yes and
         fa_disp_dt <> ?
      then do:
         {us/bbi/gprun.i ""fartbl.p""
            "(buffer fa_mstr,
              output l-err-nbr)"}
         if l-err-nbr <> 0
         then do:
            {us/bbi/pxmsg.i &MSGNUM=l-err-nbr &ERRORLEVEL=3}
         end. /* IF l-err-nbr <> 0 */
         l-error = l-err-nbr > 0.
      end. /* IF l-new-rt   = yes ... */

      /* FIND ORIGINAL ASSET */
      for first fa_mstr where fa_mstr.fa_domain = global_domain
         and fa_id = l-key
         exclusive-lock: 
      end. /* FOR FIRST fa_mstr */

      if l-error = no
      then do:
         p-status = "first-one".
         {us/bbi/gprun.i ""fafamtm.p""
            "(input p-status,
              buffer fa_mstr)"}
      end. /* IF l-error = no */
   /* ------  END  AFTER-ASSIGN-AUDIT-INCLUDE   ----------- */

   end. /* DO WITH FRAME f_1 */
END PROCEDURE. /* ip-assign */

PROCEDURE ip-predisplay:
   if perform-status = "" and
      available fa_mstr
   then
   display-loop:
   do:
      clear frame f_1 all no-pause.
      run ip-displayedits.
      run ip-postdisplay.
   end. /* DISPLAY-LOOP */
END PROCEDURE. /* ip-predisplay */

PROCEDURE ip-displayedits:
   if available fa_mstr
   then do:
      /* DISPLAY-EDITS */
      l-disp-desc = "".
      {us/px/pxrun.i &PROC='getGeneralizedCodeDescription' &PROGRAM='gpcodxr.p'
         &HANDLE=ph_gpcodxr
         &PARAM="(input 'fa_disp_rsn',
                  input fa_mstr.fa_disp_rsn,
                  output l-disp-desc)"
         &NOAPPERROR=true
         &CATCHERROR=true}

      /* DISPLAY-EDITS */
      assign
         fa_mstr.fa_dispamt:format in frame f_1 = l_amt_fmt.

      run ip-display.

   end. /* IF AVAILABLE fa_mstr */
END PROCEDURE. /* ip-displayedits */

PROCEDURE ip-display:
   display
      fa_mstr.fa_id
      fa_mstr.fa_desc1
      fa_mstr.fa_disp_dt
      fa_mstr.fa_disp_rsn
      fa_mstr.fa_dispamt
      l_cu_mstr
      l-partial
      l-disp-desc
      with frame f_1.
END PROCEDURE. /* ip-display */

PROCEDURE ip-postdisplay:
   color display message fa_id
      with frame f_1.
END PROCEDURE. /* ip-postdisplay */

PROCEDURE ip-query:
   define input-output parameter perform-status as character no-undo.
   define input-output parameter l-rowid as rowid no-undo.

   if perform-status = "first"
   then do:
      if l-rowid <> ?
      then do:
         reposition q_fa_mstr to rowid l-rowid no-error.
         get next q_fa_mstr no-lock.
      end. /* IF l-rowid <> ? */
      if not available fa_mstr
      then
         get first q_fa_mstr no-lock.
      if available fa_mstr
      then
         assign
            perform-status = ""
            l-rowid        = rowid(fa_mstr).
      else 
      do:
         assign
            perform-status    = ""
            l-rowid           = ?
            frame f_1:visible = true.
         return.
      end. /* ELSE DO */
   end. /* IF perform-status = "first" */
   if perform-status = "open"
   then do:
      open query q_fa_mstr
         for each fa_mstr where fa_mstr.fa_domain = global_domain
         and fa_id = l-key
         no-lock.

      reposition q_fa_mstr to rowid l-rowid no-error.
      get next q_fa_mstr no-lock.
      if available fa_mstr then
         assign
            perform-status = ""
            l-rowid        = rowid(fa_mstr).
      else 
      do:
         get first q_fa_mstr no-lock.
         if not available fa_mstr
         then do:
            assign
               perform-status    = ""
               frame f_1:visible = true.
            return.
         end. /* IF NOT AVAILABLE fa_mstr */
         else
            assign
               perform-status = ""
               l-rowid        = rowid(fa_mstr).
      end. /* ELSE DO */
   end. /*  IF perform-status = "open" */
   if perform-status = "next"
   then do:
      get next q_fa_mstr no-lock.
      if available fa_mstr
      then do:
         assign
            l-rowid        = rowid(fa_mstr)
            perform-status = "first".
         hide message no-pause.
         run ip-displayedits.
      end. /* IF AVAILABLE fa_mstr */
      else 
      do:
         perform-status = "".
         /* END OF FILE */
         {us/bbi/pxmsg.i &MSGNUM=20 &ERRORLEVEL=2}
         get prev q_fa_mstr no-lock.
      end. /* ELSE DO */
   end. /* IF perform-status = "next" */
   if perform-status = "prev"
   then do:
      get prev q_fa_mstr no-lock.
      if available fa_mstr
      then do:
         assign
            l-rowid        = rowid(fa_mstr)
            perform-status = "first".
         hide message no-pause.
         run ip-displayedits.
      end. /* IF AVAILABLE fa_mstr */
      else 
      do:
         perform-status = "".
         /* BEGINNING OF FILE */
         {us/bbi/pxmsg.i &MSGNUM=21 &ERRORLEVEL=2}
         get next q_fa_mstr no-lock.
      end. /* ELSE DO */
   end. /* IF perform-status = "prev" */
   if perform-status = "update" or
      perform-status = "delete"
   then do:
      get current q_fa_mstr no-lock.
      if not available fa_mstr
      then do:
         hide message no-pause.
         /* RECORD NOT FOUND */
         {us/bbi/pxmsg.i &MSGNUM=1310 &ERRORLEVEL=3}
         perform-status = "".
      end. /* IF NOT AVAILABLE fa_mstr */
   end. /* IF perform-status = "update" ... */
END PROCEDURE. /* ip-query */

PROCEDURE ip-framesetup:
   if session:display-type = "gui"
   then do:
      assign
         current-window:bgcolor = 8
         frame f_1:row          = 3.
   end. /* IF session:display-type = "gui" */
   else
      frame f_1:row = 2.

   assign
      frame f_1:box           = true
      frame f_1:title         = (getFrameTitle("RETIREMENT",16))
      frame f_1:centered      = true
      frame f-button:centered = true
      frame f-button:row      = 20.

END PROCEDURE. /* ip-framesetup */

PROCEDURE ip-button:
   define input-output parameter perform-status as character
      format "x(25)" no-undo.

   if not batchrun
   then do:
      enable all with frame f-button.
      assign
         ststatus = stline[1].
      status input ststatus.
      on choose of b-update
         do:
            assign
               perform-status = self:private-data
               l-focus        = self:handle.
            hide frame f-button no-pause.
         end. /* ON CHOOSE OF b-update */
      on choose of b-undo
         do:
            assign
               perform-status = self:private-data
               l-focus        = self:handle
               l-title        = current-window:title
                                + " - "
                                + self:label.
            hide frame f-button no-pause.
         end. /* ON CHOOSE OF b-undo */
      on choose of b-books
         do:
            assign
               perform-status = self:private-data
               l-focus        = self:handle
               l-title        = current-window:title
                                + " - "
                                + self:label.
            hide frame f-button no-pause.
         end. /* ON CHOOSE OF b-books */
      on choose of b-end
         do:
            assign
               perform-status = self:private-data
               l-focus        = self:handle.
            hide frame f_1 no-pause.
            hide frame f-button no-pause.
         end. /* ON CHOOSE OF b-end */
      on cursor-up, f9 anywhere
         do:
            assign
               perform-status = "prev"
               l-focus        = focus:handle.
            apply "go" to frame f-button.
         end. /* ON CURSOR-UP, f9 anywhere */
      on cursor-down, f10 anywhere
         do:
            assign
               perform-status = "next"
               l-focus        = focus:handle.
            apply "go" to frame f-button.
         end. /* ON CURSOR-DOWN, f10 anywhere */
      on cursor-right anywhere
         do:
            l-focus = self:handle.
            apply "tab" to l-focus.
         end. /* ON CURSOR-RIGHT anywhere */
      on cursor-left anywhere
         do:
            l-focus = self:handle.
            if session:display-type = "gui"
            then
               apply "shift-tab" to l-focus.
            else
               apply "ctrl-u" to l-focus.
         end. /* ON CURSOR-LEFT anywhere */
      on esc anywhere
         do:
            if session:display-type = "gui"
            then
               apply "choose" to b-end in frame f-button.
         end. /* ON ESC anywhere */
      on end-error anywhere
         apply "choose" to b-end in frame f-button.
      on window-close of current-window
         apply "choose" to b-end in frame f-button.
      on go anywhere
         do:
            if (lastkey = keycode("cursor-down") or
               lastkey = keycode("cursor-up")   or
               lastkey = keycode("f9")          or
               lastkey = keycode("f10"))
            then
               return.
            else
               l-focus = focus:handle.
            apply "choose" to l-focus.
         end. /* ON GO anywhere */
      wait-for
         go of frame f-button or
         window-close of current-window or
         choose of
         b-update,
         b-undo,
         b-books,
         b-end
         focus
         l-focus.

   end. /* IF NOT BATCHRUN */
   else
      set perform-status.

   hide message no-pause.
END PROCEDURE. /* ip-button */
